home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / doc / procs.lisp < prev    next >
Encoding:
Text File  |  1989-10-15  |  1.6 KB  |  60 lines
  1.  
  2.  
  3. (defun atypes (llist)
  4.   (sloop::sloop for v in llist
  5.      when (member v '(&rest &key &optional &allow-other-keys))
  6.      do (return (nconc ans '(*)))
  7.      else
  8.      collect t into ans
  9.      finally (return ans)))
  10.  
  11. (defun from-doc-file (file &optional add-rest)
  12.   ;; read from file of form (defun cons (a b) t)
  13.   ;; (defun truncate (a &optional b) (mv))
  14.   (with-open-file (st file)
  15.     (sloop::sloop  while (setq tem (read st nil nil)) with fname
  16.      when (get (setq fname (second tem)) 'compiler::lfun)
  17.      with atypes with has-ctypes
  18.      do (setq atypes (atypes (third tem)))
  19.      (multiple-value-setq
  20.       (ctypes has-ctypes)
  21.       (get fname 'compiler::arg-types))
  22.      (cond (nil (and (equal (length atypes)
  23.                 (length ctypes))
  24.              (equal (member '* atypes)
  25.                 (member '* ctypes))))
  26.            (t
  27.         (setf (gethash fname *done*) t)
  28.         (print `(defsysfun ',fname
  29.                    ,(get fname 'lfun)
  30.                    ',(cond  ((and nil(equal (length ctypes)
  31.                             (- (length atypes) 1))
  32.                          (member '* atypes))
  33.                      (append ctypes '(*)))
  34.                     ((not has-ctypes)
  35.                      atypes)
  36.                     (t `(question  ,atypes ,ctypes)))
  37.                    ',(cond ((get fname 'return-type))
  38.                        ((equal (fourth tem) '(mv)) '*)
  39.                        (t t))
  40.                    ,(get fname 'no-sp-change)
  41.                    ,(get fname 'predicate)))))))
  42.   (if add-rest (add-rest-lfuns add-rest)))
  43.  
  44.  
  45. (setq *done* (make-hash-table))
  46.  
  47. (defun add-rest-lfuns (file)
  48.   (with-open-file (st file)
  49.     (sloop::sloop while (setq tem (read st nil nil))
  50.           when (and (consp tem)
  51.                 (equal (car tem) 'defsysfun)
  52.                 (consp (second tem))
  53.                 (not (gethash (second (second tem)) *done*)))
  54.           do
  55.           (print tem))))
  56.  
  57.           
  58.                 
  59.  
  60.